module Prettify where

import Prelude hiding ((<>))
import Numeric (showHex)
import Data.Char (ord)
import Data.Bits ( Bits((.&.), shiftR) )

data Doc = Empty
         | Char Char
         | Text String
         | Line
         | Concat Doc Doc
           deriving (Show,Eq)

empty :: Doc
empty = Empty

char :: Char -> Doc
char = Char

text :: String -> Doc
text = Text

line :: Doc
line = Line

(<>) :: Doc -> Doc -> Doc
Empty <> b = b
a <> Empty = a
a <> b = Concat a b

double :: Double -> Doc
double = text . show

string :: String -> Doc
string = enclose '"' '"' . hcat . map oneChar

series :: Char -> Char -> (a -> Doc) -> [a] -> Doc
series open close item = enclose open close
                       . fsep . punctuate (char ',') . map item

oneChar :: Char -> Doc
oneChar c =
    case lookup c simpleEscapes of
        Just r -> text r
        Nothing
            | mustEscape c -> hexEscape c
            | otherwise -> char c
    where mustEscape c = c < ' ' || c == '\x7f' || c > '\xff'

simpleEscapes :: [(Char, String)]
simpleEscapes = zipWith ch "\b\n\f\r\t\\\"/" "bnfrt\\\"/"
    where ch a b = (a, ['\\', b])

hexEscape :: Char -> Doc
hexEscape c
    | d < 0x10000 = smallHex d
    | otherwise = astral (d - 0x10000)
    where d = ord c

smallHex :: Int -> Doc
smallHex x =
    text "\\u"
    <> text (replicate (4 - length h) '0')
    <> text h
    where h = showHex x ""

astral :: Int -> Doc
astral n = smallHex (a + 0xd800) <> smallHex (b + 0xdc00)
    where a = (n `shiftR` 10) .&. 0x3ff
          b = n .&. 0x3ff
                    
enclose :: Char -> Char -> Doc -> Doc
enclose left right x = char left <> x <> char right

fsep :: [Doc] -> Doc
fsep = foldr cat empty
    where cat a b = a <> Char ' ' <> b

punctuate :: Doc -> [Doc] -> [Doc]
punctuate p []     = []
punctuate p [d]    = [d]
punctuate p (d:ds) = (d <> p) : punctuate p ds

hcat :: [Doc] -> Doc
hcat = foldr (<>) empty
